home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / PowerLisp 2.01 / PowerLisp 2.01 ƒ / examples / closette-tests.lisp next >
Encoding:
Text File  |  1996-05-09  |  60.5 KB  |  1,953 lines  |  [TEXT/ROSA]
  1. ;;;-*-Mode:LISP; Package: CLOSETTE; Base:10; Syntax:Common-lisp -*-
  2.  
  3. (in-package :lisp)
  4.  
  5. ;;; CLOSette tests
  6.  
  7. ;;; From chapter 1
  8.  
  9. (defclass rectangle ()
  10.      ((height :initform 0.0 :initarg :height)
  11.       (width  :initform 0.0 :initarg :width)))
  12.  
  13. (defclass color-mixin ()
  14.      ((cyan    :initform 0 :initarg :cyan)
  15.       (magenta :initform 0 :initarg :magenta)
  16.       (yellow  :initform 0 :initarg :yellow)))
  17.  
  18. (defclass color-rectangle (color-mixin rectangle)
  19.      ((clearp :initform (y-or-n-p "But is it transparent?")
  20.               :initarg :clearp :accessor clearp)))
  21.  
  22. (defgeneric paint (x))
  23.  
  24. (defmethod paint ((x rectangle))                ;Method #1
  25.   (vertical-stroke (slot-value x 'height)
  26.                    (slot-value x 'width)))
  27.  
  28. (defmethod paint :before ((x color-mixin))      ;Method #2
  29.   (set-brush-color (slot-value x 'cyan)
  30.                    (slot-value x 'magenta)
  31.                    (slot-value x 'yellow)))
  32.  
  33. (defmethod paint ((x color-rectangle))          ;Method #3
  34.   (unless (clearp x) (call-next-method)))
  35.  
  36. (setq door
  37.       (make-instance 'color-rectangle
  38.         :width 38 :height 84 :cyan 60 :yellow 55 :clearp nil))
  39.  
  40. (defun vertical-stroke (x y) (declare (ignore x y)) (values))
  41. (defun set-brush-color (x y z) (declare (ignore x y z)) (values))
  42.  
  43. (paint door)
  44.  
  45. ;;; test method combination
  46.  
  47. (defgeneric mctest (x))
  48. (defmethod mctest :around ((x integer))
  49.   (format t "(:around integer)")
  50.   (call-next-method))
  51. (defmethod mctest :around ((x number))
  52.   (format t "(:around number)")
  53.   (call-next-method))
  54. (defmethod mctest :before ((x number))
  55.   (format t "(:before number)"))
  56. (defmethod mctest  ((x number))
  57.   (format t "(primary number)")
  58.   (1+ (call-next-method)))
  59. (defmethod mctest :after ((x number))
  60.   (format t "(:after number)"))
  61. (defmethod mctest :before ((x t))
  62.   (format t "(:before t)"))
  63. (defmethod mctest  ((x t))
  64.   (format t "(primary t)")
  65.   100)
  66. (defmethod mctest :after ((x t))
  67.   (format t "(:after t)"))
  68.  
  69. (mctest 1)
  70. #|(:around integer)(:around number)(:before number)(:before t)
  71.   (primary number)(primary t)(:after t)(:after number)
  72. 101|#
  73.  
  74. ;;; following chapter 1
  75.  
  76. (pprint (macroexpand
  77.  '(defclass color-rectangle (color-mixin rectangle)
  78.      ((clearp :initform (y-or-n-p "But is it transparent?")
  79.               :initarg :clearp :accessor clearp)))))
  80. #|(ensure-class 'color-rectangle
  81.               :direct-superclasses
  82.               (list (find-class 'color-mixin) (find-class 'rectangle))
  83.               :direct-slots
  84.               (list
  85.                (list :name 'clearp :initform
  86.                      '(y-or-n-p "But is it transparent?")
  87.                      :initfunction
  88.                      (function
  89.                       (lambda nil (y-or-n-p "But is it transparent?")))
  90.                      :initargs
  91.                      '(:clearp)
  92.                      :readers
  93.                      '(clearp)
  94.                      :writers
  95.                      '((setf clearp)))))
  96. |#
  97.  
  98.  
  99. ;;; original compute-slots
  100.  
  101. (defun original-compute-slots (class)
  102.   (mapcar #'(lambda (slot)
  103.               (make-effective-slot-definition
  104.                 :name (slot-definition-name slot)
  105.                 :initform (slot-definition-initform slot)
  106.                 :initfunction (slot-definition-initfunction slot)
  107.                 :initargs (slot-definition-initargs slot)))
  108.           (remove-duplicates
  109.             (mapappend #'class-direct-slots
  110.                        (class-precedence-list class))
  111.             :key #'slot-definition-name
  112.             :from-end t)))
  113.  
  114. (equal (original-compute-slots (find-class 'color-rectangle))
  115.        (compute-slots (find-class 'color-rectangle)))
  116. #|T|#
  117.  
  118. (pprint (macroexpand
  119.  '(defgeneric paint (x))))
  120. #|(ensure-generic-function 'paint :lambda-list '(x))|#
  121.  
  122. (pprint (macroexpand
  123.  '(defmethod paint :before ((x color-mixin))    ; Method#2
  124.   (set-brush-color (slot-value x 'cyan)
  125.                    (slot-value x 'magenta)
  126.                    (slot-value x 'yellow)))))
  127. #|(ensure-method (find-generic-function 'paint)
  128.                :lambda-list
  129.                '(x)
  130.                :qualifiers
  131.                '(:before)
  132.                :specializers
  133.                (list (find-class 'color-mixin))
  134.                :body
  135.                '(block paint
  136.                        (set-brush-color (slot-value x 'cyan)
  137.                                         (slot-value x 'magenta)
  138.                                         (slot-value x 'yellow)))
  139.                :environment
  140.                (top-level-environment))
  141. |#
  142.  
  143.  
  144. (find-generic-function 'clearp)
  145. #|#<Closette:Standard-Generic-Function CLOSETTE::CLEARP 16060700>|#
  146.  
  147. (clearp (make-instance 'color-rectangle :clearp t))
  148. #|T|#
  149.  
  150. ;;; change-class
  151.  
  152. (setq o1 (make-instance 'rectangle :height 10 :width 20))
  153. (describe-object o1 *standard-output*)
  154. #| A CLOS object
  155. Printed representation: #<Rectangle 16166710>
  156. Class: #<Standard-Class rectangle 15253764>
  157. Structure 
  158.     height <- 10
  159.     width <- 20
  160. |#
  161.  
  162. (change-class o1 'color-mixin)
  163. (describe-object o1 *standard-output*)
  164. #| A CLOS object
  165. Printed representation: #<Color-Mixin 16166710>
  166. Class: #<Standard-Class color-mixin 15274440>
  167. Structure 
  168.     cyan <- 0
  169.     magenta <- 0
  170.     yellow <- 0
  171. |#
  172. (change-class o1 'standard-object)
  173. (describe-object o1 *standard-output*)
  174. #| A CLOS object
  175. Printed representation: #<Standard-Object 16166710>
  176. Class: #<Standard-Class standard-object 15071700>
  177. Structure
  178. |#
  179.  
  180. (sub-specializer-p (find-class 'color-mixin)
  181.                    (find-class 'rectangle)
  182.                    (find-class 'color-rectangle))
  183. #|T|#
  184. (sub-specializer-p (find-class 'rectangle)
  185.                    (find-class 'rectangle)
  186.                    (find-class 'color-rectangle))
  187. #|NIL|#
  188.  
  189. ;;; exercise
  190.  
  191. (defvar all-tables (make-hash-table :test #'eq))
  192.  
  193. (defun classes-to-applicable-methods-table (gf)
  194.   (let ((table (gethash gf all-tables nil)))
  195.     (unless table
  196.       (setq table (make-hash-table :test #'equal))
  197.       (setf (gethash gf all-tables) table))
  198.     table))
  199.  
  200. (defun better-apply-generic-function (gf args)
  201.   (let* ((required-classes
  202.             (mapcar #'class-of (required-portion gf args)))
  203.          (applicable-methods
  204.             (or (gethash required-classes
  205.                          (classes-to-applicable-methods-table gf)
  206.                          nil)
  207.                 (setf (gethash required-classes
  208.                                (classes-to-applicable-methods-table gf))
  209.                       (compute-applicable-methods-using-classes
  210.                         gf required-classes)))))
  211.     (if (null applicable-methods)
  212.         (error "No matching method for the~@
  213.                 generic function ~S,~@
  214.                 when called with arguments ~:S." gf args)
  215.         (apply-methods gf args applicable-methods))))
  216.  
  217. (better-apply-generic-function 
  218.  (find-generic-function 'make-instance)
  219.  (list 'rectangle))
  220.  
  221. ;;; From chapter 2:
  222.  
  223. (defun subclasses* (class)
  224.   (remove-duplicates
  225.     (cons class 
  226.           (mapappend #'subclasses* 
  227.                      (class-direct-subclasses class)))))
  228.  
  229. (defun subclasses (class) (remove class (subclasses* class)))
  230.  
  231. (subclasses (find-class 'rectangle))
  232. #|(#<Standard-Class COLOR-RECTANGLE>)|#
  233.  
  234. (defvar my-classes 
  235.   (mapcar #'class-name
  236.           (subclasses (find-class 'standard-object))))
  237.  
  238. my-classes
  239. #|(color-mixin rectangle
  240.              color-rectangle
  241.              standard-method
  242.              standard-generic-function
  243.              standard-class)
  244. |#
  245.  
  246.  
  247. (defun display-defclass (class-name)
  248.   (pprint (generate-defclass (find-class class-name)))
  249.   (values))
  250.  
  251. (defun generate-defclass (class)
  252.   `(defclass ,(class-name class)
  253.      ,(mapcar #'class-name (class-direct-superclasses class))
  254.      ,(mapcar #'generate-slot-specification (class-direct-slots class))))
  255.  
  256. (defun generate-slot-specification (slot)
  257.   `(,(slot-definition-name slot)
  258.     ,@(when (slot-definition-initfunction slot)
  259.         `(:initform ,(slot-definition-initform slot)))
  260.     ,@(when (slot-definition-initargs slot)
  261.         (mapappend #'(lambda (initarg) `(:initarg ,initarg))
  262.                    (slot-definition-initargs slot)))
  263.     ,@(unless (eq (slot-definition-allocation slot) ':instance)
  264.         `(:allocation ,(slot-definition-allocation slot)))
  265.     ,@(when (slot-definition-readers slot)
  266.         (mapappend #'(lambda (reader) `(:reader ,reader))
  267.                    (slot-definition-readers slot)))
  268.     ,@(when (slot-definition-writers slot)
  269.         (mapappend #'(lambda (writer) `(:writer ,writer))
  270.                    (slot-definition-writers slot)))))
  271.  
  272. (display-defclass 'rectangle)
  273. #|(DEFCLASS RECTANGLE (STANDARD-OBJECT)
  274.      ((HEIGTH :INITFORM 0.0 :INITARG :HEIGTH)
  275.       (WIDTH :INITFORM 0.0 :INITARG :WIDTH)))|#
  276.  
  277. (display-defclass 't)
  278. #|(DEFCLASS T () ())|#
  279.  
  280. (display-defclass 'standard-object)
  281. #|(DEFCLASS STANDARD-OBJECT (T) ()) |#
  282.  
  283. (defun display-defclass* (class-name)
  284.   (pprint (generate-defclass* (find-class class-name)))
  285.   (values))
  286.  
  287. (defun generate-defclass* (class)
  288.   `(defclass* ,(class-name class)
  289.      ,(mapcar #'class-name (cdr (class-precedence-list class)))
  290.      ,(mapcar #'(lambda (slot)
  291.                   (generate-inherited-slot-specification class slot))
  292.               (class-slots class))))
  293.  
  294. (defun generate-inherited-slot-specification (class slot)
  295.   (let* ((source-class
  296.            (find-if #'(lambda (superclass)
  297.                         (find (slot-definition-name slot)
  298.                               (class-direct-slots superclass)
  299.                               :key #'slot-definition-name))
  300.                     (class-precedence-list class)))
  301.          (generated-slot-spec
  302.            (generate-slot-specification slot)))
  303.     (if (eq source-class class)
  304.         generated-slot-spec
  305.         (append generated-slot-spec
  306.                 `(:inherited-from ,(class-name source-class))))))
  307.  
  308. (display-defclass* 'color-rectangle)
  309. #|(defclass* color-rectangle
  310.            (color-mixin rectangle standard-object t)
  311.            ((clearp :initform
  312.                     (y-or-n-p "But is it transparent?")
  313.                     :initarg
  314.                     :clearp)
  315.             (cyan :initform
  316.                   0
  317.                   :initarg
  318.                   :cyan
  319.                   :inherited-from
  320.                   color-mixin)
  321.             (magenta :initform
  322.                      0
  323.                      :initarg
  324.                      :magenta
  325.                      :inherited-from
  326.                      color-mixin)
  327.             (yellow :initform
  328.                     0
  329.                     :initarg
  330.                     :yellow
  331.                     :inherited-from
  332.                     color-mixin)
  333.             (height :initform
  334.                     0.0
  335.                     :initarg
  336.                     :height
  337.                     :inherited-from
  338.                     rectangle)
  339.             (width :initform
  340.                    0.0
  341.                    :initarg
  342.                    :width
  343.                    :inherited-from
  344.                    rectangle)))
  345. |#
  346.  
  347. (defclass color-chart (rectangle color-mixin) ())
  348.  
  349. (mapcar #'class-name (class-precedence-list
  350.                            (find-class 'color-rectangle)))
  351. #|(COLOR-RECTANGLE COLOR-MIXIN RECTANGLE STANDARD-OBJECT T)|#
  352.  
  353. (mapcar #'class-name (class-precedence-list
  354.                            (find-class 'color-chart)))
  355. #|(COLOR-CHART RECTANGLE COLOR-MIXIN STANDARD-OBJECT T)|#
  356.  
  357. (defun in-order-p (c1 c2)
  358.   (flet ((in-order-at-subclass-p (sub)
  359.            (let ((cpl (class-precedence-list sub)))
  360.               (not (null (member c2 (cdr (member c1 cpl))))))))
  361.     (or (eq c1 c2)
  362.         (every #'in-order-at-subclass-p
  363.                (intersection (subclasses* c1)
  364.                              (subclasses* c2))))))
  365.  
  366. (in-order-p (find-class 'color-mixin)
  367.                 (find-class 'rectangle))
  368. #|NIL|#
  369.  
  370. (in-order-p (find-class 'standard-object)
  371.                 (find-class 't))
  372. #|T|#
  373.  
  374. (defclass position ()
  375.      (x y))
  376. (defclass cad-element (position) ())
  377. (defclass display-element (position) ())
  378. (defclass displayable-cad-element (display-element cad-element) ())
  379.  
  380. (defun has-diamond-p (class)
  381.   (some #'(lambda (pair)
  382.             (not (null (common-subclasses* (car pair)
  383.                                            (cadr pair)))))
  384.         (all-distinct-pairs (class-direct-subclasses class))))
  385.  
  386. (defun common-subclasses* (class-1 class-2)
  387.   (intersection (subclasses* class-1) (subclasses* class-2)))
  388.  
  389. (defun all-distinct-pairs (set)
  390.   (if (null set)
  391.       ()
  392.       (append (mapcar #'(lambda (rest)
  393.                           (list (car set) rest)) 
  394.                       (cdr set))
  395.               (all-distinct-pairs (cdr set)))))
  396.  
  397. (has-diamond-p (find-class 'position))
  398. #|t|#
  399.  
  400. (has-diamond-p (find-class 'rectangle))
  401. #|nil|#
  402.  
  403. (defun generate-defgeneric (gf)
  404.   `(defgeneric ,(generic-function-name gf)
  405.      ,(generic-function-lambda-list gf)))
  406.  
  407. (defun generate-defmethod (method &key show-body)
  408.   `(defmethod ,(generic-function-name (method-generic-function method))
  409.      ,@(method-qualifiers method)
  410.      ,(generate-specialized-arglist method)
  411.      ,@(when show-body (list (method-body method)))))
  412.  
  413. (defun generate-specialized-arglist (method)
  414.   (let* ((specializers (method-specializers method))
  415.          (lambda-list (method-lambda-list method))
  416.          (number-required (length specializers)))
  417.     (append (mapcar #'(lambda (arg class)
  418.                         (if (eq class (find-class 't))
  419.                             arg
  420.                             `(,arg ,(class-name class))))
  421.                     (subseq lambda-list 0 number-required)
  422.                     specializers)
  423.             (subseq lambda-list number-required))))
  424.  
  425. (defun display-generic-function (gf-name &key show-body)
  426.   (display-defgeneric gf-name)
  427.   (dolist (method (generic-function-methods (find-generic-function gf-name)))
  428.     (pprint (generate-defmethod method :show-body show-body)))
  429.   (values))
  430.  
  431. (defun display-defgeneric (gf-name)
  432.   (pprint (generate-defgeneric (find-generic-function gf-name)))
  433.   (values))
  434.  
  435.  
  436. (display-generic-function 'paint :show-body t)
  437. #|(DEFGENERIC PAINT (X))
  438. (DEFMETHOD PAINT ((X RECTANGLE))
  439.   (BLOCK PAINT
  440.    (VERTICAL-STROKE (SLOT-VALUE X 'HEIGHT)
  441.                     (SLOT-VALUE X 'WIDTH))))
  442. (DEFMETHOD PAINT :BEFORE ((X COLOR-MIXIN))
  443.   (BLOCK PAINT
  444.    (SET-BRUSH-COLOR (SLOT-VALUE X 'CYAN)
  445.                     (SLOT-VALUE X 'MAGENTA)
  446.                     (SLOT-VALUE X 'YELLOW))))
  447. (DEFMETHOD PAINT ((X COLOR-RECTANGLE))    
  448.   (BLOCK PAINT
  449.     (UNLESS (CLEARP X) (CALL-NEXT-METHOD))))
  450. |#
  451.  
  452. (display-generic-function 'clearp :show-body t)
  453. #|(DEFGENERIC CLEARP (OBJECT))
  454. (DEFMETHOD CLEARP ((OBJECT COLOR-RECTANGLE))
  455.   (SLOT-VALUE OBJECT 'CLEARP)) |#
  456.  
  457. (display-generic-function '(setf clearp) :show-body t)
  458. #|(DEFGENERIC (SETF CLEARP) (NEW-VALUE OBJECT))
  459. (DEFMETHOD (SETF CLEARP) ((OBJECT COLOR-RECTANGLE))
  460.   (SETF (SLOT-VALUE OBJECT 'CLEARP) NEW-VALUE)) |#
  461.  
  462. (display-generic-function 'shared-initialize)
  463. #|(DEFGENERIC SHARED-INITIALIZE (INSTANCE SLOT-NAMES &KEY))
  464. (DEFMETHOD SHARED-INITIALIZE ((INSTANCE STANDARD-OBJECT)
  465.                               SLOT-NAMES &REST ALL-KEYS))|#
  466.  
  467. (defun all-generic-functions ()
  468.   (remove-duplicates 
  469.     (mapappend #'class-direct-generic-functions
  470.                (subclasses* (find-class 't)))))
  471.  
  472. (defun class-direct-generic-functions (class)
  473.   (remove-duplicates 
  474.      (mapcar #'method-generic-function
  475.              (class-direct-methods class))))
  476.  
  477. (mapcar #'generic-function-name (all-generic-functions))
  478. #|(CLEARP PAINT UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
  479. REINITIALIZE-INSTANCE INITIALIZE-INSTANCE CHANGE-CLASS
  480. MAKE-INSTANCE (SETF CLEARP) SHARED-INITIALIZE
  481. PRINT-OBJECT \ldots)|#
  482.  
  483. (defun relevant-generic-functions (class ceiling)
  484.   (remove-duplicates
  485.     (mapcar #'method-generic-function
  486.       (mapappend #'class-direct-methods
  487.         (set-difference (class-precedence-list class)
  488.                         (class-precedence-list ceiling))))))
  489.  
  490. (relevant-generic-functions (find-class 'color-rectangle)
  491.                             (find-class 'standard-object))
  492. #|(#<Standard-Generic-Function paint 16031414>
  493.  #<Standard-Generic-Function (setf clearp) 16021300>
  494.  #<Standard-Generic-Function clearp 16016120>)|#
  495.  
  496. (defun display-effective-method (gf args)
  497.   (let ((applicable-methods
  498.            (compute-applicable-methods-using-classes
  499.              gf (mapcar #'class-of (required-portion gf args)))))
  500.     (pprint
  501.       (if (null applicable-methods)
  502.           '(error "No applicable methods.")
  503.           (generate-effective-method gf applicable-methods)))))
  504.  
  505. (defun generate-effective-method (gf methods)
  506.   (declare (ignore gf))
  507.   (labels ((generate-method (method)
  508.              `(method ,@(cdr (generate-defmethod
  509.                               method :show-body t))))
  510.            (generate-call-method (method next-methods)
  511.              `(call-method
  512.                 ,(generate-method method)
  513.                 ,(mapcar #'generate-method next-methods))))
  514.     (let ((primaries (remove-if-not #'primary-method-p methods))
  515.           (befores (remove-if-not #'before-method-p methods))
  516.           (afters (remove-if-not #'after-method-p methods)))
  517.       (if (null primaries)
  518.           '(error "No primary method")
  519.           `(progn
  520.              ,@(mapcar
  521.                  #'(lambda (method)
  522.                      (generate-call-method method ()))
  523.                  befores)
  524.              (multiple-value-prog1
  525.                ,(generate-call-method (car primaries)
  526.                                       (cdr primaries))
  527.                ,@(mapcar
  528.                    #'(lambda (method)
  529.                        (generate-call-method method ()))
  530.                    (reverse afters))))))))
  531.  
  532.  
  533. (display-effective-method (find-generic-function 'paint)
  534.                           (list (make-instance 'color-rectangle 
  535.                                                :clearp nil)))
  536. #|(progn
  537.  (call-method
  538.   (method paint
  539.           :before
  540.           ((x color-mixin))
  541.           (block paint
  542.                  (set-brush-color (slot-value x 'cyan)
  543.                                   (slot-value x 'magenta)
  544.                                   (slot-value x 'yellow))))
  545.   nil)
  546.  (multiple-value-prog1
  547.   (call-method
  548.    (method paint
  549.            ((x color-rectangle))
  550.            (block paint (unless (clearp x) (call-next-method))))
  551.    ((method paint
  552.             ((x rectangle))
  553.             (block paint
  554.                    (vertical-stroke (slot-value x 'height)
  555.                                     (slot-value x 'width))))))))
  556. |#
  557. (display-effective-method (find-generic-function 'paint)
  558.                           (list (make-instance 'rectangle)))
  559. #|(progn
  560.  (multiple-value-prog1
  561.   (call-method
  562.    (method paint
  563.            ((x rectangle))
  564.            (block paint
  565.                   (vertical-stroke (slot-value x 'height)
  566.                                    (slot-value x 'width))))
  567.    nil)))
  568. |#
  569.  
  570. (defun reader-method-p (method)
  571.   (let ((specializers (method-specializers method)))
  572.     (and (= (length specializers) 1)
  573.          (member (generic-function-name (method-generic-function method))
  574.                  (mapappend #'slot-definition-readers
  575.                             (class-direct-slots (car specializers)))
  576.                  :test #'equal))))
  577.  
  578. (defun writer-method-p (method)
  579.   (let ((specializers (method-specializers method)))
  580.     (and (= (length specializers) 2)
  581.          (member (generic-function-name (method-generic-function method))
  582.                  (mapappend #'slot-definition-writers
  583.                             (class-direct-slots (cadr specializers)))
  584.                  :test #'equal))))
  585.  
  586. (defun relevant-generic-functions (class ceiling &key elide-accessors-p)
  587.   (remove-duplicates
  588.     (mapcar #'method-generic-function
  589.       (remove-if #'(lambda (m)
  590.                      (and elide-accessors-p
  591.                           (or (reader-method-p m)
  592.                               (writer-method-p m))))
  593.         (mapappend #'class-direct-methods
  594.           (set-difference (class-precedence-list class)
  595.                           (class-precedence-list ceiling)))))))
  596. (relevant-generic-functions (find-class 'color-rectangle)
  597.                             (find-class 'standard-object)
  598.                             :elide-accessors-p 't)
  599. #|(#<Standard-Generic-Function paint 15316224>)|#
  600.  
  601.  
  602. (defclass shape () ())
  603. (defclass circle (shape) ())
  604. (defclass triangle (shape) ())
  605. (defclass pentagon (shape) ())
  606.  
  607. (defclass label-type () ())
  608. (defclass top-labeled (label-type) ())
  609. (defclass center-labeled (label-type) ())
  610. (defclass bottom-labeled (label-type) ())
  611.  
  612. (defclass color () ())
  613. (defclass fuschia (color) ())
  614. (defclass orange  (color) ())
  615. (defclass magenta (color) ())
  616.  
  617. (defun make-programmatic-instance (superclass-names &rest initargs)
  618.   (apply #'make-instance
  619.          (find-programmatic-class
  620.            (mapcar #'find-class superclass-names))
  621.          initargs))
  622.  
  623. (defun find-programmatic-class (superclasses)
  624.   (let ((class (find-if
  625.                  #'(lambda (class)
  626.                      (equal superclasses
  627.                             (class-direct-superclasses class)))
  628.                  (class-direct-subclasses (car superclasses)))))
  629.     (if class
  630.         class
  631.         (make-programmatic-class superclasses))))
  632.  
  633. (defun make-programmatic-class (superclasses)
  634.   (make-instance 'standard-class
  635.     :name (mapcar #'class-name superclasses)
  636.     :direct-superclasses superclasses
  637.     :direct-slots ()))
  638.  
  639. (make-programmatic-instance '(circle orange top-labeled)
  640.                             :title "Color Wheel"
  641.                             :radius 10)
  642. #|#<(Circle Orange Top-Labeled) 16023764>|#
  643.  
  644. (class-direct-subclasses (find-class 'circle))
  645. #|(#<Standard-Class (circle orange top-labeled) 16021350>)|#
  646.  
  647. (setq i1 (make-programmatic-instance
  648.               '(circle orange top-labeled))
  649.           i2 (make-programmatic-instance
  650.               '(circle magenta bottom-labeled))
  651.           i3 (make-programmatic-instance
  652.               '(circle orange top-labeled)))
  653.  
  654. (class-direct-subclasses (find-class 'circle))
  655. #|(#<Standard-Class (circle magenta bottom-labeled) 16043060>
  656.  #<Standard-Class (circle orange top-labeled) 16021350>)|#
  657.  
  658. ;;; From chapter 3
  659.  
  660. (defclass counted-class (standard-class)
  661.      ((counter :initform 0)))
  662.  
  663. (setf (find-class 'counted-rectangle)
  664.           (make-instance 'counted-class
  665.             :name 'counted-rectangle
  666.             :direct-superclasses (list (find-class 'rectangle))
  667.             :direct-slots ()))
  668.  
  669. (class-of (find-class 'rectangle))
  670. #|#<Standard-Class STANDARD-CLASS 12505420>|#
  671.  
  672. (class-of (find-class 'counted-rectangle))
  673. #|#<Standard-Class COUNTED-CLASS 69547893> |#
  674.  
  675. #|(slot-value (find-class 'rectangle) 'counter)
  676. Error: The slot COUNTER is missing from the class 
  677. #<Standard-Class STANDARD-CLASS 15501664>.|#
  678.  
  679. (slot-value (find-class 'counted-rectangle) 'counter)
  680. #|0|#
  681.  
  682. (defmethod make-instance :after ((class counted-class) &key)
  683.   (incf (slot-value class 'counter)))
  684.  
  685. (slot-value (find-class 'counted-rectangle) 'counter)
  686. #|0|#
  687. (make-instance 'counted-rectangle)
  688. (slot-value (find-class 'counted-rectangle) 'counter)
  689. #|1|#
  690.  
  691. (pprint (macroexpand
  692. '(defclass counted-rectangle (rectangle)
  693.      ()
  694.   (:metaclass counted-class))))
  695. #|(ENSURE-CLASS 'COUNTED-RECTANGLE
  696.               :DIRECT-SUPERCLASSES
  697.               (LIST (FIND-CLASS 'RECTANGLE))
  698.               :DIRECT-SLOTS
  699.               (LIST)
  700.               :METACLASS
  701.               (FIND-CLASS 'COUNTED-CLASS))|#
  702.  
  703.  
  704. (print-object (find-class 'counted-rectangle) *standard-output*)
  705. #|#<Closette::Counted-Class CLOSETTE::COUNTED-RECTANGLE 16252370>|#
  706.  
  707. (print-object (find-class 'rectangle) *standard-output*)
  708. #|#<Closette:Standard-Class CLOSETTE::RECTANGLE 15730444>|#
  709.  
  710. ;;; alternative cpls
  711.  
  712. (defclass loops-class (standard-class) ())
  713. (defclass flavors-class (standard-class) ())
  714.  
  715. (defmethod compute-class-precedence-list ((class loops-class))
  716.   (append (remove-duplicates
  717.             (depth-first-preorder-superclasses* class)
  718.             :from-end nil)
  719.           (list (find-class 'standard-object) 
  720.                 (find-class 't))))
  721.  
  722. (defmethod compute-class-precedence-list ((class flavors-class))
  723.   (append (remove-duplicates
  724.             (depth-first-preorder-superclasses* class)
  725.             :from-end t)
  726.           (list (find-class 'standard-object) 
  727.                 (find-class 't))))
  728.  
  729. (defun depth-first-preorder-superclasses* (class)
  730.   (if (eq class (find-class 'standard-object))
  731.       ()
  732.       (cons class (mapappend #'depth-first-preorder-superclasses*
  733.                              (class-direct-superclasses class)))))
  734.  
  735. (defclass a () ())
  736. (defclass b () ())
  737. (defclass c () ())
  738. (defclass s (a b) ())
  739. (defclass r (a c) ())
  740. (defclass q-clos (s r) () (:metaclass standard-class))
  741. (defclass q-loops (s r) () (:metaclass loops-class))
  742. (defclass q-flavors (s r) () (:metaclass flavors-class))
  743.  
  744. (pprint (class-precedence-list (find-class 'q-flavors)))
  745. #|(q-flavors s a b r c standard-object t)|#
  746.  
  747. (pprint (class-precedence-list (find-class 'q-loops)))
  748. #|(q-loops s b r a c standard-object t)|#
  749.  
  750. (pprint (class-precedence-list (find-class 'q-clos)))
  751. #|(q-clos s r a c b standard-object t)|#
  752.  
  753. (defclass vanilla-flavor () ())
  754.  
  755. (defmethod initialize-instance :around ((class flavors-class)
  756.                                         &rest all-keys
  757.                                         &key direct-superclasses)
  758.   (apply #'call-next-method
  759.          class
  760.          :direct-superclasses (or direct-superclasses
  761.                                   (list (find-class 'vanilla-flavor)))
  762.          all-keys))
  763.  
  764. (defclass flavors-test () () (:metaclass flavors-class))
  765. (pprint (class-precedence-list (find-class 'flavors-test)))
  766. #|(#<Flavors-Class flavors-test 16222110>
  767.  #<Standard-Class vanilla-object 16213600>
  768.  #<Standard-Class standard-object 15075604>
  769.  #<Standard-Class t 15060104>)|#
  770.  
  771. ;;; attributes
  772.  
  773. (defclass attributes-class (standard-class) ())
  774.  
  775. (defun slot-definition-attributes (slot)
  776.   (getf slot ':attributes ()))
  777. (defun (setf slot-definition-attributes) (new-value slot)
  778.   (setf (getf* slot ':attributes) new-value))
  779.  
  780. (defmethod compute-effective-slot-definition ((class attributes-class)
  781.                                               direct-slots)
  782.   (let ((normal-slot (call-next-method)))
  783.     (setf (slot-definition-attributes normal-slot)
  784.           (remove-duplicates
  785.             (mapappend #'slot-definition-attributes
  786.                        direct-slots)))
  787.     normal-slot))
  788.  
  789. (defmethod compute-slots ((class attributes-class))
  790.   (let ((normal-slots (call-next-method)))
  791.     (flet ((initial-attribute-alist (slots)
  792.              (mapcar
  793.                #'(lambda (slot)
  794.                    (cons (slot-definition-name slot)
  795.                          (mapcar #'(lambda (attr) (cons attr nil))
  796.                                  (slot-definition-attributes slot))))
  797.                slots)))
  798.       (let ((alist (initial-attribute-alist normal-slots)))
  799.         (cons (make-effective-slot-definition
  800.                 :name 'all-attributes
  801.                 :initform alist
  802.                 :initfunction #'(lambda () alist))
  803.               normal-slots)))))
  804.  
  805. (defun slot-attribute (instance slot-name attribute)
  806.   (cdr (slot-attribute-bucket instance slot-name attribute)))
  807.  
  808. (defun (setf slot-attribute) (new-value instance slot-name attribute)
  809.   (setf (cdr (slot-attribute-bucket
  810.                instance slot-name attribute))
  811.         new-value))
  812.  
  813. (defun slot-attribute-bucket (instance slot-name attribute)
  814.   (let* ((all-buckets (slot-value instance 'all-attributes))
  815.          (slot-bucket (assoc slot-name all-buckets)))
  816.     (unless slot-bucket
  817.       (error "The slot named ~A of ~S has no attributes."
  818.              slot-name instance))
  819.     (let ((attr-bucket (assoc attribute (cdr slot-bucket))))
  820.       (unless attr-bucket
  821.         (error "The slot named ~A of ~S has no attribute~@
  822.                 named ~A." slot-name instance attribute))
  823.       attr-bucket)))
  824.  
  825. (defclass credit-rating ()
  826.      ((level :attributes (date-set time-set)))
  827.   (:metaclass attributes-class))
  828.  
  829. (setq cr (make-instance 'credit-rating))
  830. (slot-attribute cr 'level 'date-set)
  831. #|NIL|#
  832. (setf (slot-attribute cr 'level 'date-set) "12/15/90")
  833. (slot-attribute cr 'level 'date-set)
  834. #|"12/15/90"|#
  835.  
  836. (defclass monitored-credit-rating (credit-rating)
  837.      ((level :attributes (last-checked interval)))
  838.   (:metaclass attributes-class))
  839.  
  840. (slot-value cr 'all-attributes)
  841. #|((level . ((date-set . "12/15/90") (time-set . nil))))|#
  842. (slot-value (make-instance 'monitored-credit-rating) 
  843.             'all-attributes)
  844. #| ((level . ((last-checked . nil) (interval . nil) 
  845.               (date-set .nil ) (time-set .nil))))|#
  846.  
  847. ;;; encapsulated classes
  848.  
  849. (defclass encapsulated-class (standard-class) ())
  850.  
  851. (defmethod initialize-instance :around ((class encapsulated-class)
  852.                                         &rest all-keys
  853.                                         &key direct-slots)
  854.   (let ((revised-direct-slots
  855.           (mapcar
  856.             #'(lambda (slot-properties)
  857.                 (let ((pretty-name (getf slot-properties ':name))
  858.                       (new-properties (copy-list slot-properties)))
  859.                   (setf (getf* new-properties ':name) (gensym))
  860.                   (setf (getf* new-properties ':pretty-name) pretty-name)
  861.                   new-properties))
  862.             direct-slots)))
  863.     (apply #'call-next-method class
  864.            :direct-slots revised-direct-slots
  865.            all-keys)))
  866.  
  867. (defun slot-definition-pretty-name (slot)
  868.   (getf slot ':pretty-name))
  869.  
  870. (defun (setf slot-definition-pretty-name) (new-value slot)
  871.   (setf (getf* slot ':pretty-name) new-value))
  872.  
  873. (defun private-slot-value (instance slot-name class-name)
  874.   (slot-value instance (private-slot-name slot-name class-name)))
  875.  
  876. (defun private-slot-name (slot-name class-name)
  877.   (let* ((class (find-class class-name))
  878.          (slot (find slot-name
  879.                      (class-direct-slots class)
  880.                      :key #'slot-definition-pretty-name)))
  881.     (if slot
  882.         (slot-definition-name slot)
  883.         (error "The class ~S has no private slot named ~S."
  884.                class-name slot-name))))
  885.  
  886. (defclass c1 ()
  887.      ((foo :reader foo :initform 100))
  888.   (:metaclass encapsulated-class))
  889. (class-direct-slots (find-class 'c1))
  890. (defclass c2 (c1)
  891.      ((foo :reader foo :initform 200))
  892.   (:metaclass encapsulated-class))
  893. (class-direct-slots (find-class 'c2))
  894.  
  895. (defgeneric mumble (o))
  896. (defmethod mumble ((o c1))
  897.   (private-slot-value o 'foo 'c1))
  898. (defmethod mumble ((o c2))
  899.   (+ (private-slot-value o 'foo 'c2)
  900.      (call-next-method)))
  901.  
  902. (mumble (make-instance 'c1))
  903. #|100|#
  904.  
  905. (mumble (make-instance 'c2))
  906. #|300|# 
  907.  
  908.  
  909. ;;; default initargs
  910.  
  911. (pprint (macroexpand 
  912. '(defclass frame (rectangle)
  913.      ()
  914.   (:metaclass default-initargs-class)
  915.   (:default-initargs :width 10))))
  916. #|(ensure-class 'frame
  917.               :direct-superclasses
  918.                 (list (find-class 'rectangle))
  919.               :direct-slots ()
  920.               :metaclass
  921.                 (find-class 'default-initargs-class)
  922.               :direct-default-initargs
  923.                 (list ':width 10))|#
  924.  
  925. (defclass default-initargs-class (standard-class)
  926.           ((direct-default-initargs         
  927.             :initarg :direct-default-initargs
  928.             :initform ()
  929.             :accessor class-direct-default-initargs)))
  930.  
  931. (defun compute-class-default-initargs (class)
  932.  (mapappend #'class-direct-default-initargs
  933.             (class-precedence-list class)))
  934.  
  935. (defmethod class-direct-default-initargs ((class standard-class))
  936.   ())
  937.  
  938. (defmethod make-instance ((class default-initargs-class) &rest initargs)
  939.   (apply #'call-next-method
  940.          class
  941.          (append initargs
  942.                  (compute-class-default-initargs class))))
  943.  
  944. (defclass frame (rectangle)
  945.      ()
  946.   (:metaclass default-initargs-class)
  947.   (:default-initargs :width 10))
  948.  
  949. (setq f (make-instance 'frame :height 20))
  950. (slot-value f 'height)
  951. #|20|#
  952. (slot-value f 'width)
  953. #|10|#
  954. (setq g (make-instance 'frame :height 20 :width 10))
  955. (slot-value g 'height)
  956. #|20|#
  957. (slot-value g 'width)
  958. #|10|#
  959.  
  960.  
  961. ;;; precomputed default initargs
  962.  
  963. (defclass default-initargs-class-2 (standard-class)
  964.      ((direct-default-initargs                   
  965.         :initarg :direct-default-initargs
  966.         :initform ()
  967.         :accessor class-direct-default-initargs)
  968.       (effective-default-initargs
  969.         :accessor class-default-initargs)))
  970.  
  971. (defmethod finalize-inheritance :after ((class default-initargs-class-2))
  972.   (setf (class-default-initargs class)
  973.         (compute-class-default-initargs class)))
  974.  
  975. (defmethod make-instance ((class default-initargs-class-2) &rest initargs)
  976.   (apply #'call-next-method
  977.          class
  978.          (append initargs (class-default-initargs class))))
  979.  
  980. (defun compute-class-default-initargs (class)
  981.   (mapappend #'class-direct-default-initargs
  982.              (class-precedence-list class)))
  983.  
  984. (defmethod class-default-initargs ((class standard-class))
  985.   ())
  986.  
  987. (defclass frame-2 (rectangle)
  988.      ()
  989.   (:metaclass default-initargs-class-2)
  990.   (:default-initargs :width 10))
  991.  
  992. (setq f (make-instance 'frame-2 :height 20))
  993. (slot-value f 'height)
  994. #|20|#
  995. (slot-value f 'width)
  996. #|10|#
  997.  
  998. ;;;
  999.  
  1000. (defmacro new-defclass (name direct-superclasses direct-slots
  1001.                              &rest options)
  1002.   (let* ((metaclass-option
  1003.            (find ':metaclass options :key #'car))
  1004.          (metaclass-name (if metaclass-option
  1005.                              (cadr metaclass-option)
  1006.                              'standard-class))
  1007.          (sample-class-metaobject
  1008.            (allocate-instance (find-class metaclass-name)))
  1009.          (canonical-supers
  1010.            (canonicalize-direct-superclasses direct-superclasses))
  1011.          (canonical-slots
  1012.            (canonicalize-direct-slots direct-slots))
  1013.          (canonical-options
  1014.            (new-canonicalize-defclass-options
  1015.              sample-class-metaobject
  1016.              (remove metaclass-option options))))
  1017.   `(ensure-class ',name
  1018.      :direct-superclasses ,canonical-supers
  1019.      :direct-slots ,canonical-slots
  1020.      :metaclass (find-class ',metaclass-name)
  1021.      ,@canonical-options)))
  1022.  
  1023. (defun new-canonicalize-defclass-options (sample-class options)
  1024.   (mapappend #'(lambda (option)
  1025.                  (new-canonicalize-defclass-option sample-class option))
  1026.              options))
  1027.  
  1028. (defgeneric new-canonicalize-defclass-option (sample-class option))
  1029. (defmethod new-canonicalize-defclass-option
  1030.            ((sample-class standard-class) option)
  1031.    (error "Unrecognized defclass option ~S." option))
  1032.  
  1033. (defmethod new-canonicalize-defclass-option
  1034.            ((sample-class default-initargs-class) option)
  1035.   (case (car option)
  1036.     (:default-initargs
  1037.       (list
  1038.        ':direct-default-initargs
  1039.        `(list ,@(mapappend
  1040.                   #'(lambda (x) x)
  1041.                   (mapplist
  1042.                     #'(lambda (key value)
  1043.                         `(',key ,value))
  1044.                     (cdr option))))))
  1045.     (t (call-next-method))))
  1046.  
  1047. (pprint (macroexpand 
  1048. '(new-defclass frame-2 (rectangle)
  1049.      ()
  1050.   (:metaclass default-initargs-class)
  1051.   (:default-initargs :width 10))))
  1052. #|(ensure-class 'frame-2
  1053.               :direct-superclasses
  1054.               (list (find-class 'rectangle))
  1055.               :direct-slots
  1056.               (list)
  1057.               :metaclass
  1058.               (find-class 'default-initargs-class)
  1059.               :direct-default-initargs
  1060.               (list ':width 10))
  1061. |#
  1062.  
  1063. ;;; slot access
  1064.  
  1065. (defclass monitored-class (standard-class) ())
  1066.  
  1067. (defmethod slot-value-using-class :before
  1068.            ((class monitored-class) instance slot-name)
  1069.   (note-operation instance slot-name 'slot-value))
  1070.  
  1071. (defmethod (setf slot-value-using-class) :before
  1072.            (new-value (class monitored-class)
  1073.             instance slot-name)
  1074.   (note-operation instance slot-name 'set-slot-value))
  1075.  
  1076. (defmethod slot-boundp-using-class :before
  1077.            ((class monitored-class) instance slot-name)
  1078.   (note-operation instance slot-name 'slot-boundp))
  1079.  
  1080. (defmethod slot-makunbound-using-class :before
  1081.            ((class monitored-class) instance slot-name)
  1082.   (note-operation instance slot-name 'slot-makunbound))
  1083.  
  1084. (let ((history-list ()))
  1085.   (defun note-operation (instance slot-name operation)
  1086.     (push `(,operation ,instance ,slot-name) history-list)
  1087.     (values))
  1088.  
  1089.   (defun reset-slot-access-history ()
  1090.     (setq history-list ())
  1091.     (values))
  1092.  
  1093.   (defun slot-access-history ()
  1094.     (reverse history-list))
  1095.  )
  1096.  
  1097. (defclass foo () 
  1098.      ((slot1 :accessor foo-slot1 :initarg :slot1) 
  1099.       (slot2 :accessor foo-slot2 :initform 200))
  1100.   (:metaclass monitored-class))
  1101.  
  1102. (reset-slot-access-history)
  1103. (setq i (make-instance 'foo :slot1 100))
  1104. #|#<FOO 3813124>|#
  1105.  
  1106. (setf (slot-value i 'slot1) (foo-slot2 i))
  1107. (incf (foo-slot1 i))
  1108.  
  1109. (pprint (slot-access-history))
  1110. #|((set-slot-value #<Foo 17122130> slot1)
  1111.  (slot-boundp #<Foo 17122130> slot2)
  1112.  (set-slot-value #<Foo 17122130> slot2)
  1113.  (slot-value #<Foo 17122130> slot2)
  1114.  (set-slot-value #<Foo 17122130> slot1)
  1115.  (slot-value #<Foo 17122130> slot1)
  1116.  (set-slot-value #<Foo 17122130> slot1))
  1117. |#
  1118.  
  1119. (defclass history-class (standard-class) ())
  1120.  
  1121. (defun slot-definition-history (slot)
  1122.   (getf slot ':history nil))
  1123. (defun (setf slot-definition-history) (new-value slot)
  1124.   (setf (getf* slot ':history) new-value))
  1125. (defun slot-definition-history-slot-name (slot)
  1126.   (getf slot ':history-slot-name nil))
  1127. (defun (setf slot-definition-history-slot-name) (new-value slot)
  1128.   (setf (getf* slot ':history-slot-name) new-value))
  1129.  
  1130. (defmethod compute-slots ((class history-class))
  1131.   (let ((normal-slots (call-next-method)))
  1132.     (mapappend
  1133.       #'(lambda (slot)
  1134.           (if (null (slot-definition-history slot))
  1135.               (list slot)
  1136.               (let ((extra-slot
  1137.                       (make-effective-slot-definition
  1138.                         :name (slot-definition-history-slot-name slot)
  1139.                         :history nil)))
  1140.                 (list slot extra-slot))))
  1141.       normal-slots)))
  1142.  
  1143. (defmethod compute-effective-slot-definition ((class history-class)
  1144.                                               direct-slots)
  1145.   (let ((initer (find-if-not #'null direct-slots
  1146.                              :key #'slot-definition-initfunction)))
  1147.     (make-effective-slot-definition
  1148.       :name (slot-definition-name (car direct-slots))
  1149.       :history (some #'slot-definition-history direct-slots)
  1150.       :history-slot-name (gensym)
  1151.       :allocation (slot-definition-allocation (car direct-slots))
  1152.       :initform (if initer
  1153.                     (slot-definition-initform initer)
  1154.                     nil)
  1155.       :initfunction (if initer
  1156.                         (slot-definition-initfunction initer)
  1157.                          nil)
  1158.       :initargs (remove-duplicates
  1159.                   (mapappend #'slot-definition-initargs
  1160.                              direct-slots)))))
  1161.  
  1162. (defmethod allocate-instance ((class history-class))
  1163.   (let ((instance (call-next-method)))
  1164.     (dolist (slot (class-slots class))
  1165.       (when (slot-definition-history slot)
  1166.         (setf (slot-value
  1167.                 instance
  1168.                 (slot-definition-history-slot-name slot))
  1169.               ())))
  1170.     instance))
  1171.  
  1172. (defun slot-history (instance slot-name)
  1173.   (unless (slot-exists-p instance slot-name)
  1174.     (error "~S has no slot named ~A." instance slot-name))
  1175.   (let ((slot (find slot-name (class-slots (class-of instance))
  1176.                     :key #'slot-definition-name)))
  1177.     (if (slot-definition-history slot)
  1178.         (slot-value instance
  1179.                     (slot-definition-history-slot-name slot))
  1180.         ())))
  1181.  
  1182. (defmethod (setf slot-value-using-class) :before
  1183.            (new-value (class history-class) instance slot-name)
  1184.   (remember-previous-value instance slot-name))
  1185.  
  1186. (defmethod slot-makunbound-using-class :before
  1187.            ((class history-class) instance slot-name)
  1188.   (remember-previous-value instance slot-name))
  1189.  
  1190. (defun remember-previous-value (instance slot-name)
  1191.   (let ((slot (find slot-name (class-slots (class-of instance))
  1192.                     :key #'slot-definition-name)))
  1193.     (when (and (not (null slot))
  1194.                (slot-definition-history slot))
  1195.       (push (if (slot-boundp instance slot-name)
  1196.                 (slot-value instance slot-name)
  1197.                 'unbound)
  1198.             (slot-value
  1199.               instance
  1200.               (slot-definition-history-slot-name slot))))))
  1201.  
  1202. (defclass meter ()
  1203.      ((size :initarg meter-size)
  1204.       (reading :initform 0 :history t))
  1205.   (:metaclass history-class))
  1206.  
  1207. (class-slots (find-class 'meter))
  1208. #|((:name size
  1209.         :history
  1210.         nil
  1211.         :history-slot-name
  1212.         #:g1680
  1213.         :allocation
  1214.         :instance
  1215.         :initform
  1216.         nil
  1217.         :initfunction
  1218.         nil
  1219.         :initargs
  1220.         (meter-size))
  1221.  (:name reading
  1222.         :history
  1223.         t
  1224.         :history-slot-name
  1225.         #:g1681
  1226.         :allocation
  1227.         :instance
  1228.         :initform
  1229.         0
  1230.         :initfunction
  1231.         #<An Anonymous Compiled Function>
  1232.         :initargs
  1233.         nil)
  1234.  (:name #:g1681
  1235.         :history
  1236.         nil
  1237.         :initargs
  1238.         nil
  1239.         :allocation
  1240.         :instance))
  1241. |#
  1242.  
  1243. (setq meter1 (make-instance 'meter))
  1244. (setf (slot-value meter1 'reading) 200)
  1245. (slot-history meter1 'size)
  1246. (slot-history meter1 'reading)
  1247. #|(0 unbound)|#
  1248.  
  1249. ;;; dynamic-slot-class
  1250.  
  1251. (defclass dynamic-slot-class (standard-class) ())
  1252.  
  1253. (defmethod compute-effective-slot-definition
  1254.           ((class dynamic-slot-class) direct-slots)
  1255.   (let ((slot (call-next-method)))
  1256.     (setf (slot-definition-allocation slot) ':dynamic)
  1257.     slot))
  1258.  
  1259. (defun dynamic-slot-p (slot)
  1260.   (eq (slot-definition-allocation slot) ':dynamic))
  1261.  
  1262. (defmethod allocate-instance ((class dynamic-slot-class) &key)
  1263.   (let ((instance (call-next-method)))
  1264.     (allocate-table-entry instance)
  1265.     instance))
  1266.  
  1267. (defmethod slot-value-using-class ((class dynamic-slot-class)
  1268.                                    instance slot-name)
  1269.   (let ((slot (find slot-name (class-slots class)
  1270.                     :key #'slot-definition-name)))
  1271.     (if slot
  1272.         (read-dynamic-slot-value instance slot-name)
  1273.         (call-next-method))))
  1274.  
  1275. (defmethod slot-boundp-using-class ((class dynamic-slot-class)
  1276.                                    instance slot-name)
  1277.   (let ((slot (find slot-name (class-slots class)
  1278.                     :key #'slot-definition-name)))
  1279.     (if slot
  1280.         (dynamic-slot-boundp instance slot-name)
  1281.         (call-next-method))))
  1282.  
  1283. (defmethod (setf slot-value-using-class)
  1284.            (new-value (class dynamic-slot-class)
  1285.             instance slot-name)
  1286.   (let ((slot (find slot-name (class-slots class)
  1287.                     :key #'slot-definition-name)))
  1288.     (if slot
  1289.       (write-dynamic-slot-value new-value instance slot-name)
  1290.       (call-next-method))))
  1291.  
  1292. (defmethod slot-makunbound-using-class ((class dynamic-slot-class)
  1293.                                    instance slot-name)
  1294.   (let ((slot (find slot-name (class-slots class)
  1295.                     :key #'slot-definition-name)))
  1296.     (if slot
  1297.         (dynamic-slot-makunbound instance slot-name)
  1298.         (call-next-method))))
  1299.  
  1300. (let ((table (make-hash-table :test #'eq)))
  1301.  
  1302.   (defun allocate-table-entry (instance)
  1303.     (setf (gethash instance table) ()))
  1304.  
  1305.   (defun read-dynamic-slot-value (instance slot-name)
  1306.     (let* ((alist (gethash instance table))
  1307.            (entry (assoc slot-name alist)))
  1308.       (if (null entry)
  1309.           (error "The slot ~S is unbound in the object ~S."
  1310.                  slot-name instance)
  1311.           (cdr entry))))
  1312.  
  1313.   (defun write-dynamic-slot-value (new-value instance slot-name)
  1314.     (let* ((alist (gethash instance table))
  1315.            (entry (assoc slot-name alist)))
  1316.       (if (null entry)
  1317.           (push `(,slot-name . ,new-value)
  1318.                 (gethash instance table))
  1319.           (setf (cdr entry) new-value))
  1320.       new-value))
  1321.  
  1322.   (defun dynamic-slot-boundp (instance slot-name)
  1323.     (let* ((alist (gethash instance table))
  1324.            (entry (assoc slot-name alist)))
  1325.       (not (null entry))))
  1326.  
  1327.   (defun dynamic-slot-makunbound (instance slot-name)
  1328.     (let* ((alist (gethash instance table))
  1329.            (entry (assoc slot-name alist)))
  1330.       (unless (null entry)
  1331.         (setf (gethash instance table)
  1332.               (delete entry alist))))
  1333.     instance)
  1334.   )
  1335.  
  1336. (defclass biggy ()
  1337.      (a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1
  1338.       n1 o1 p1 q1 r1 s1 t1 u1 v1 w1 x1 y1 z1
  1339.       a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2
  1340.       n2 o2 p2 q2 r2 s2 t2 u2 v2 w2 x2 y2 z2
  1341.       a3 b3 c3 d3 e3 f3 g3 h3 i3 j3 k3 l3 m3
  1342.       n3 o3 p3 q3 r3 s3 t3 u3 v3 w3 x3 y3 z3
  1343.       a4 b4 c4 d4 e4 f4 g4 h4 i4 j4 k4 l4 m4
  1344.       n4 o4 p4 q4 r4 s4 t4 u4 v4)
  1345.   (:metaclass dynamic-slot-class))
  1346.  
  1347. (every #'dynamic-slot-p
  1348.         (class-slots (find-class 'biggy)))
  1349. #|t|#
  1350.  
  1351. (setq b1 (make-instance 'biggy))
  1352.  
  1353. (setf (slot-value b1 'f3) 'b1-f3-value)
  1354.  
  1355. (slot-value b1 'f3)
  1356. #|b1-f3-value|#
  1357.  
  1358. (defclass dynamic-slot-class-2 (standard-class) ())
  1359.  
  1360. (defmethod allocate-instance ((class dynamic-slot-class-2) &key)
  1361.   (let ((instance (call-next-method)))
  1362.     (when (some #'dynamic-slot-p (class-slots class))
  1363.       (allocate-table-entry instance))
  1364.     instance))
  1365.  
  1366. (defmethod slot-value-using-class ((class dynamic-slot-class-2)
  1367.                                    instance slot-name)
  1368.   (let ((slot (find slot-name (class-slots class)
  1369.                     :key #'slot-definition-name)))
  1370.     (if (and slot (dynamic-slot-p slot))
  1371.         (read-dynamic-slot-value instance slot-name)
  1372.         (call-next-method))))
  1373.  
  1374. (defmethod slot-boundp-using-class ((class dynamic-slot-class-2)
  1375.                                    instance slot-name)
  1376.   (let ((slot (find slot-name (class-slots class)
  1377.                     :key #'slot-definition-name)))
  1378.     (if (and slot (dynamic-slot-p slot))
  1379.       (dynamic-slot-boundp instance slot-name)
  1380.       (call-next-method))))
  1381.  
  1382. (defmethod (setf slot-value-using-class)
  1383.            (new-value (class dynamic-slot-class-2)
  1384.             instance slot-name)
  1385.   (let ((slot (find slot-name (class-slots class)
  1386.                     :key #'slot-definition-name)))
  1387.     (if (and slot (dynamic-slot-p slot))
  1388.         (write-dynamic-slot-value new-value instance slot-name)
  1389.         (call-next-method))))
  1390.  
  1391. (defmethod slot-makunbound-using-class ((class dynamic-slot-class-2)
  1392.                                    instance slot-name)
  1393.   (let ((slot (find slot-name (class-slots class)
  1394.                     :key #'slot-definition-name)))
  1395.     (if (and slot (dynamic-slot-p slot))
  1396.       (dynamic-slot-makunbound instance slot-name)
  1397.       (call-next-method))))
  1398.  
  1399. (defclass movable-rectangle (rectangle)
  1400.      ((previous-height :allocation :dynamic)
  1401.       (previous-width :allocation :dynamic))
  1402.   (:metaclass dynamic-slot-class-2))
  1403.  
  1404. (setq mr (make-instance 'movable-rectangle))
  1405. (every #'dynamic-slot-p
  1406.         (class-slots (find-class 'movable-rectangle)))
  1407. #|nil|#
  1408.  
  1409. (some #'dynamic-slot-p
  1410.         (class-slots (find-class 'movable-rectangle)))
  1411. #|t|#
  1412.  
  1413. (setf (slot-value mr 'height) 1002)
  1414. (setf (slot-value mr 'previous-height) 999)
  1415.  
  1416. (slot-value mr 'height)
  1417. #|1002|#
  1418. (slot-value mr 'previous-height)
  1419. #|999|#
  1420.  
  1421. ;;;
  1422.  
  1423. (defclass class-slot-class (standard-class)
  1424.      ((class-allocated-slot-values
  1425.         :initform ()
  1426.         :accessor class-allocated-slots)))
  1427.  
  1428. (defun class-slot-p (slot)
  1429.   (eq (slot-definition-allocation slot) ':class))
  1430.  
  1431. (defvar unbound-class-slot (list "unbound class slot"))
  1432.  
  1433. (defmethod initialize-instance :after
  1434.            ((class class-slot-class) &key)
  1435.   (setf (class-allocated-slots class)
  1436.         (mapappend
  1437.           #'(lambda (slot)
  1438.               (if (class-slot-p slot)
  1439.                   (let ((initfunction
  1440.                           (slot-definition-initfunction slot)))
  1441.                     (list (cons (slot-definition-name slot)
  1442.                                 (if (not (null initfunction))
  1443.                                     (funcall initfunction)
  1444.                                     unbound-class-slot))))
  1445.                   ()))
  1446.           (class-direct-slots class))))
  1447.  
  1448. #|(defmethod finalize-inheritance :after
  1449.            ((class class-slot-class))
  1450.   (setf (class-allocated-slots class)
  1451.         (mapappend
  1452.           #'(lambda (slot)
  1453.               (if (class-slot-p slot)
  1454.                   (let ((initfunction
  1455.                           (slot-definition-initfunction slot)))
  1456.                     (if (not (null initfunction))
  1457.                         (list (cons (slot-definition-name slot)
  1458.                                     (funcall initfunction)))
  1459.                         (list (cons (slot-definition-name slot)
  1460.                                     secret-unbound-value))))
  1461.                   ()))
  1462.           (class-direct-slots class))))|#
  1463.  
  1464. (defun class-slot-value (class slot-name)
  1465.   (dolist (super (class-precedence-list class))
  1466.      (let ((slot (find slot-name (class-direct-slots super)
  1467.                        :key #'slot-definition-name)))
  1468.         (when slot
  1469.            (let ((value (cdr (assoc slot-name
  1470.                                     (class-allocated-slots super)))))
  1471.              (when (eq value secret-unbound-value)
  1472.                 (error "Unbound class slot named ~A in class ~S."
  1473.                        slot-name class))
  1474.              (return-from class-slot-value value))))))
  1475.  
  1476. (defun (setf class-slot-value) (new-value class slot-name)
  1477.   (block class-slot-value
  1478.     (dolist (super (class-precedence-list class))
  1479.       (let ((slot (find slot-name (class-direct-slots super)
  1480.                         :key #'slot-definition-name)))
  1481.         (when slot
  1482.           (setf (cdr (assoc slot-name
  1483.                             (class-allocated-slots super)))
  1484.                 new-value)
  1485.           (return-from class-slot-value new-value))))))
  1486.  
  1487. (defun class-slot-boundp (class slot-name)
  1488.   (dolist (super (class-precedence-list class))
  1489.      (let ((slot (find slot-name (class-direct-slots super)
  1490.                        :key #'slot-definition-name)))
  1491.         (when slot
  1492.            (let ((value (cdr (assoc slot-name
  1493.                                     (class-allocated-slots super)))))
  1494.              (return-from class-slot-boundp 
  1495.                           (eq value secret-unbound-value)))))))
  1496.  
  1497. (defun class-slot-makunbound (class slot-name)
  1498.   (dolist (super (class-precedence-list class))
  1499.      (let ((slot (find slot-name (class-direct-slots super)
  1500.                        :key #'slot-definition-name)))
  1501.         (when slot
  1502.            (setf (cdr (assoc slot-name
  1503.                              (class-allocated-slots super)))
  1504.                  secret-unbound-value)
  1505.            (return-from class-slot-makunbound)))))
  1506.  
  1507. (defmethod slot-value-using-class
  1508.            ((class class-slot-class)
  1509.             instance slot-name)
  1510.   (let ((slot (find slot-name (class-slots class)
  1511.                     :key #'slot-definition-name)))
  1512.     (if (and slot (class-slot-p slot))
  1513.         (class-slot-value class slot-name)
  1514.         (call-next-method))))
  1515.  
  1516. (defmethod (setf slot-value-using-class)
  1517.             (new-value
  1518.              (class class-slot-class)
  1519.               instance slot-name)
  1520.   (let ((slot (find slot-name (class-slots class)
  1521.                     :key #'slot-definition-name)))
  1522.     (if (and slot (class-slot-p slot))
  1523.         (setf (class-slot-value class slot-name) new-value)
  1524.         (call-next-method))))
  1525.  
  1526. (defmethod slot-boundp-using-class
  1527.            ((class class-slot-class)
  1528.             instance slot-name)
  1529.   (let ((slot (find slot-name (class-slots class)
  1530.                     :key #'slot-definition-name)))
  1531.     (if (and slot (class-slot-p slot))
  1532.         (class-slot-boundp class slot-name)
  1533.         (call-next-method))))
  1534.  
  1535. (defmethod slot-makunbound-using-class
  1536.            ((class class-slot-class)
  1537.             instance slot-name)
  1538.   (let ((slot (find slot-name (class-slots class)
  1539.                     :key #'slot-definition-name)))
  1540.     (if (and slot (class-slot-p slot))
  1541.         (progn (class-slot-makunbound class slot-name)
  1542.                instance)
  1543.         (call-next-method))))
  1544.  
  1545. (defclass labeled-rectangle (rectangle)
  1546.      ((font :initform 'old-english-12
  1547.             :allocation :class))
  1548.   (:metaclass class-slot-class))
  1549.  
  1550. (setq lr1 (make-instance 'labeled-rectangle))
  1551. (setq lr2 (make-instance 'labeled-rectangle))
  1552.  
  1553. (slot-value lr1 'font)
  1554. #|OLD-ENGLISH-12|#
  1555.  
  1556. (setf (slot-value lr1 'font) 'times-roman-10)
  1557.  
  1558. (slot-value lr2 'font)
  1559. #|TIMES-ROMAN-10|#
  1560.  
  1561. (defclass both-slots-class (dynamic-slot-class class-slot-class)
  1562.      ())
  1563.  
  1564. ;;; chapter 4
  1565.  
  1566. (pprint (macroexpand 
  1567. '(defgeneric paint (x)
  1568.   (:generic-function-class specialized-generic-function)
  1569.   (:method-class specialized-method))))
  1570. #|(ensure-generic-function 'paint
  1571.                          :lambda-list
  1572.                          '(x)
  1573.                          :generic-function-class
  1574.                          (find-class 'specialized-generic-function)
  1575.                          :method-class
  1576.                          (find-class 'specialized-method))|#
  1577.  
  1578. ;;; counter example
  1579.  
  1580.  
  1581. (defclass counting-gf (standard-generic-function) 
  1582.   ((call-count :initform 0 :accessor call-count)))
  1583.  
  1584. (defclass counting-method (standard-method) 
  1585.   ((call-count :initform 0 :accessor call-count)))
  1586.  
  1587. (defmethod compute-discriminating-function ((gf counting-gf))
  1588.   (let ((normal-dfun (call-next-method)))
  1589.     #'(lambda (&rest args)
  1590.         (incf (call-count gf))
  1591.         (apply normal-dfun args))))
  1592.  
  1593. (defmethod compute-method-function ((method counting-method))
  1594.   (let ((normal-method-function (call-next-method)))
  1595.      #'(lambda (args next-methods)
  1596.          (incf (call-count method))
  1597.          (funcall normal-method-function args next-methods))))
  1598.  
  1599. (defgeneric ack (x)
  1600.   (:generic-function-class counting-gf)
  1601.   (:method-class counting-method))
  1602. (defmethod ack :before ((x standard-object)) nil)
  1603. (defmethod ack (x) t)
  1604.  
  1605. (ack (make-instance 'standard-object))
  1606. #|T|#
  1607.  
  1608. (ack 1)
  1609. #|T|#
  1610.  
  1611. (call-count (find-generic-function 'ack))
  1612. #|2|#
  1613. (mapcar #'(lambda (method)
  1614.                 (list (generate-defmethod method)
  1615.                       (call-count method)))
  1616.             (generic-function-methods (find-generic-function 'ack)))
  1617. #|(((DEFMETHOD ACK :BEFORE ((X STANDARD-OBJECT))) 1)
  1618.  ((DEFMETHOD ACK (X)) 2))|#
  1619.  
  1620. ;;; tracing gf exercise
  1621.  
  1622. (defclass traceable-gf (standard-generic-function)
  1623.      ((tracing :initform nil :accessor tracing-enabled-p)))
  1624.  
  1625. (defun trace-generic-function (gf-name new-value)
  1626.   (let ((gf (find-generic-function gf-name)))
  1627.     (setf (tracing-enabled-p gf) new-value)))
  1628.  
  1629. (defmethod compute-discriminating-function ((gf traceable-gf))
  1630.   (let ((normal-dfun (call-next-method)))
  1631.     #'(lambda (&rest args)
  1632.         (if (not (tracing-enabled-p gf))
  1633.             (apply normal-dfun args)
  1634.             (progn
  1635.               (format *trace-output*
  1636.                       "Entering generic function ~S~@
  1637.                        with arguments ~:S.~%" gf args)
  1638.               (let ((results (multiple-value-list 
  1639.                               (apply normal-dfun args))))
  1640.                 (format *trace-output*
  1641.                         "Leaving generic function ~S~@
  1642.                          value(s) being returned are: ~:S.~%"
  1643.                         gf results)
  1644.                 (values-list results)))))))
  1645.  
  1646. (defgeneric testf (x)
  1647.   (:generic-function-class traceable-gf))
  1648. (defmethod testf (x) x)
  1649.  
  1650. (trace-generic-function 'testf t)
  1651. (testf 10)
  1652. #|Entering generic function #<Traceable-Gf testf 16774634>
  1653. with arguments (10).
  1654. Leaving generic function #<Traceable-Gf testf 16774634>
  1655. value(s) being returned are: (10)
  1656. 10|#
  1657.  
  1658. (trace-generic-function 'testf nil)
  1659. (testf 20)
  1660. #|20|#
  1661.  
  1662. ;;; trusting gfs
  1663.  
  1664. (defclass trusting-gf (standard-generic-function) ()) 
  1665.  
  1666. (defmethod compute-discriminating-function ((gf trusting-gf))
  1667.   (let ((normal-dfun (call-next-method))
  1668.         (methods (generic-function-methods gf)))
  1669.     (if (and (= (length methods) 1)
  1670.              (primary-method-p (car methods)))
  1671.         #'(lambda (&rest args)
  1672.             (apply-method (car methods) args ()))
  1673.         normal-dfun)))
  1674.  
  1675. (defgeneric gfoo (x) (:generic-function-class trusting-gf))
  1676. (defmethod gfoo ((x standard-object))
  1677.   x)
  1678.  
  1679. (gfoo (find-class 'standard-class))
  1680. #|#<Standard-Class STANDARD-CLASS 15102564>|#
  1681.  
  1682. (gfoo 100)
  1683. #|100|#
  1684.  
  1685. (defmethod gfoo ((x number))
  1686.   (1+ x))
  1687.  
  1688. (gfoo 100)
  1689. #|101|#
  1690.  
  1691. (defclass trusting-counting-gf (trusting-gf counting-gf) ())
  1692.  
  1693. (defgeneric flack (x)
  1694.   (:generic-function-class trusting-counting-gf)
  1695.   (:method-class counting-method))
  1696. (defmethod flack (x) t)
  1697.  
  1698. (flack (make-instance 'standard-object))
  1699. #|T|#
  1700.  
  1701. (flack 1)
  1702. #|T|#
  1703.  
  1704. (call-count (find-generic-function 'flack))
  1705. #|0|#
  1706. (mapcar #'(lambda (method)
  1707.                 (list (generate-defmethod method)
  1708.                       (call-count method)))
  1709.             (generic-function-methods 
  1710.              (find-generic-function 'flack)))
  1711. #|(((DEFMETHOD ACK :BEFORE ((X STANDARD-OBJECT))) 1)
  1712.  ((DEFMETHOD ACK (X)) 2))|#
  1713.  
  1714. (defclass counting-trusting-gf (counting-gf trusting-gf) ())
  1715.  
  1716. (defgeneric flack2 (x)
  1717.   (:generic-function-class counting-trusting-gf)
  1718.   (:method-class counting-method))
  1719. (defmethod flack2 (x) t)
  1720.  
  1721. (flack2 (make-instance 'standard-object))
  1722. #|T|#
  1723.  
  1724. (flack2 1)
  1725. #|T|#
  1726.  
  1727. (call-count (find-generic-function 'flack2))
  1728. #|2|#
  1729.  
  1730. ;;; encapsulated methods (can't be tested because they need
  1731. ;;; to add bindings to body
  1732.  
  1733. #|
  1734. (defclass c1 ()
  1735.      ((foo :initform 100))
  1736.   (:metaclass encapsulated-class))
  1737. (defclass c2 (c1)
  1738.      ((foo :initform 200))
  1739.   (:metaclass encapsulated-class))
  1740.  
  1741. (defgeneric f1 (x)
  1742.   (:generic-function-class encapsulating-gf)
  1743.   (:method-class encapsulated-method))
  1744.  
  1745. (defmethod f1 ((y c1))
  1746.   (1- (slot 'foo)))
  1747. (defmethod f1 ((z c2))
  1748.   (1+ (slot 'foo)))
  1749.  
  1750. (f1 (make-instance 'c1))
  1751. 99
  1752. (f1 (make-instance 'c2))
  1753. 201
  1754. |#
  1755.  
  1756. ;;; Method Combination
  1757.  
  1758. (defclass gf-with-arounds (standard-generic-function) ())
  1759.  
  1760. #|(defmethod apply-methods ((gf gf-with-arounds) args methods)
  1761.   (let ((around (find-if #'around-method-p methods)))
  1762.     (if around
  1763.         (apply-method around args (remove around methods))
  1764.         (call-next-method))))|#
  1765.  
  1766. (defmethod compute-effective-method-function
  1767.   ((gf gf-with-arounds) methods)
  1768.   (let ((around (find-if #'around-method-p methods)))
  1769.     (if around
  1770.         #'(lambda (args)
  1771.             (apply-method around args (remove around methods)))
  1772.         (call-next-method))))
  1773.  
  1774. (defgeneric gfa (x) (:generic-function-class gf-with-arounds))
  1775. (defmethod gfa :around ((x integer))
  1776.   (format t "(:around integer)")
  1777.   (call-next-method))
  1778. (defmethod gfa :around ((x number))
  1779.   (format t "(:around number)")
  1780.   (call-next-method))
  1781. (defmethod gfa :before ((x number))
  1782.   (format t "(:before number)"))
  1783. (defmethod gfa  ((x number))
  1784.   (format t "(primary number)")
  1785.   (1+ (call-next-method)))
  1786. (defmethod gfa :after ((x number))
  1787.   (format t "(:after number)"))
  1788. (defmethod gfa :before ((x t))
  1789.   (format t "(:before t)"))
  1790. (defmethod gfa  ((x t))
  1791.   (format t "(primary t)")
  1792.   100)
  1793. (defmethod gfa :after ((x t))
  1794.   (format t "(:after t)"))
  1795.  
  1796. (gfa 1)
  1797. #|(:around integer)(:around number)(:before number)(:before t)
  1798.   (primary number)(primary t)(:after t)(:after number)
  1799. 101|#
  1800.  
  1801.  
  1802. (defclass gf-with-append (standard-generic-function) ())
  1803.  
  1804. #|
  1805. (defmethod apply-methods ((gf gf-with-append) args methods)
  1806.   (mapappend #'(lambda (method)
  1807.                  (apply-method method args ()))
  1808.              methods))
  1809. |#
  1810.  
  1811. (defmethod compute-effective-method-function
  1812.   ((gf gf-with-append) methods)
  1813.   #'(lambda (args)
  1814.       (apply #'append
  1815.              (mapcar #'(lambda (method)
  1816.                          (apply-method method args ()))
  1817.                      methods))))
  1818.  
  1819. (defgeneric gfappend (x)
  1820.   (:generic-function-class gf-with-append))
  1821. (defmethod gfappend ((x integer))
  1822.   '(integer))
  1823. (defmethod gfappend ((x number))
  1824.   '(number))
  1825. (defmethod gfappend ((x t))
  1826.   '(t))
  1827.  
  1828. (gfappend 1)
  1829. #|(INTEGER NUMBER T)|#
  1830.  
  1831. ;;; Argument Precedence Order
  1832.  
  1833. (defclass apo-gf (standard-generic-function)
  1834.      ((argument-precedence-order
  1835.          :initarg :argument-precedence-order
  1836.          :accessor argument-precedence-order)))
  1837.  
  1838. (defmethod initialize-instance :after ((gf apo-gf) &key)
  1839.   (unless (slot-boundp gf 'argument-precedence-order)
  1840.     (setf (argument-precedence-order gf)
  1841.           (gf-required-arglist gf))))
  1842.  
  1843. (defmethod method-more-specific-p
  1844.            ((gf apo-gf) method1 method2 required-classes)
  1845.   (flet ((apo-permute (list)
  1846.             (mapcar #'(lambda (arg-name)
  1847.                         (nth (position
  1848.                                arg-name
  1849.                                (gf-required-arglist gf))
  1850.                              list))
  1851.                     (argument-precedence-order gf))))
  1852.     (mapc #'(lambda (spec1 spec2 arg-class)
  1853.               (unless (eq spec1 spec2)
  1854.                  (return-from method-more-specific-p
  1855.                    (sub-specializer-p spec1 spec2 arg-class))))
  1856.           (apo-permute (method-specializers method1))
  1857.           (apo-permute (method-specializers method2))
  1858.           (apo-permute required-classes))
  1859.     nil))
  1860.  
  1861. (defgeneric multigf (x y)
  1862.   (:generic-function-class apo-gf)
  1863.   (:argument-precedence-order (y x)))
  1864.  
  1865. (defmethod multigf ((x t) (y number))
  1866.   (format t "(t number)")
  1867.   (values))
  1868. (defmethod multigf ((x number) (y t))
  1869.   (format t "(number t)")
  1870.   (values))
  1871. (defmethod multigf ((x number) (y number))
  1872.   (format t "(number number)")
  1873.   (values))
  1874. (defmethod multigf ((x t) (y integer))
  1875.   (format t "(t integer)")
  1876.   (values))
  1877. (defmethod multigf ((x t) (y t))
  1878.   (format t "(t t)")
  1879.   (values))
  1880.  
  1881. (multigf 1 2)
  1882. #|(t integer)|#
  1883. (multigf 1 'a)
  1884. #|(number t)|#
  1885. (multigf 'b 'a)
  1886. #|(t t)|#
  1887. (multigf  'b 1)
  1888. #|(t integer)|#
  1889.  
  1890. (defgeneric multigf2 (x y))
  1891. (defmethod multigf2 ((x t) (y number))
  1892.   (format t "(t number)")
  1893.   (values))
  1894. (defmethod multigf2 ((x number) (y t))
  1895.   (format t "(number t)")
  1896.   (values))
  1897. (defmethod multigf2 ((x number) (y number))
  1898.   (format t "(number number)")
  1899.   (values))
  1900. (defmethod multigf2 ((x t) (y integer))
  1901.   (format t "(t integer)")
  1902.   (values))
  1903. (defmethod multigf2 ((x t) (y t))
  1904.   (format t "(t t)")
  1905.   (values))
  1906.  
  1907. (multigf2 1 2)
  1908. #|(number number)|#
  1909. (multigf2 1 'a)
  1910. #|(number t)|#
  1911. (multigf2 'b 'a)
  1912. #|(t t)|#
  1913. (multigf2  'b 1)
  1914. #|(t integer)|#
  1915.  
  1916. ;;; beta
  1917.  
  1918. (defclass beta-gf (standard-generic-function) ())
  1919.  
  1920. (defmethod method-more-specific-p ((gf beta-gf) method1 method2 classes)
  1921.   (if (equal (method-specializers method1)
  1922.              (method-specializers method2))
  1923.       nil
  1924.       (not (call-next-method))))
  1925.  
  1926. (defmacro inner (&rest args)
  1927.   `(if (next-method-p)
  1928.        (call-next-method ,@args)
  1929.        nil))
  1930.  
  1931. (defgeneric bjorn (x)
  1932.   (:generic-function-class beta-gf))
  1933.  
  1934. (defmethod bjorn (x)
  1935.   (format t " general ")
  1936.   (inner))
  1937. (defmethod bjorn ((x number))
  1938.   (format t " number ")
  1939.   (inner))
  1940.  
  1941. (bjorn 1)
  1942. #|  general  number |#
  1943. (bjorn 'a)
  1944. #|  general |#
  1945.  
  1946.  
  1947. "done"
  1948.  
  1949.  
  1950.  
  1951.  
  1952.  
  1953.